Explore

data <- read_csv("Mental_Health_copy.csv", 
                 col_types = cols(`Quartile Range` = col_skip(), 
                                  `Suppression Flag` = col_skip(),
                                  # LowCI = col_skip(),
                                  # HighCI= col_skip(),
                                  `Confidence Interval`= col_skip()
                                  )) %>%
  mutate(CIint = HighCI-LowCI) 

Temporal by state and indicator

Took Prescription Medication for Mental Health, Last 4 Weeks

# taking prescription filter
data_states_13_meds <- data %>% 
  filter(Indicator == "Took Prescription Medication for Mental Health, Last 4 Weeks",
         Group == "By State" ) %>% 
  mutate(State1 = tolower(State)) %>%
  select(Value, CIint, State = State1, Indicator, t = `Time Period`, `Time Period Label`) 

Resources for Value-Suppressing Uncertainty Palettes: https://github.com/clauswilke/multiscales

MainStates <- map_data("state") %>% mutate(State = tolower(region)) 
merged_pres <- inner_join(MainStates, data_states_13_meds, by = "State")

region.lab.data <- merged_pres %>%
  group_by(State) %>% summarise(long=mean(long), lat=mean(lat))

# Color for Value-Suppressing Uncertainty Palettes
colors <- scales::colour_ramp(
  colors = c(red = "#AC202F", purple = "#740280", blue = "#2265A3")
)((0:7)/7)

#---- VSUP ggplot

# map_took_pres <- ggplot(merged_pres) +
#   geom_polygon(aes(x=long, y=lat, group=group, fill = zip(Value, CIint), frame =  t), 
#                color="white", size = 0.2) +
#   bivariate_scale("fill",
#                   pal_vsup(values = colors, max_desat = 0.8, pow_desat = 0.2, max_light = 0.7, pow_light = 1),
#                   name = c("Percentage", "uncertainty"),
#                   # limits = list(c(min(merged_pres$Value), max(merged_pres$Value)),
#                                 # c(min(merged_pres$CIint), max(merged_pres$CIint))),
#                   breaks = list(waiver(), c(0, 1)),
#                   # breaks = list(c(10, 15, 20, 25, 30, 35), c(0, 5, 10, 15, 20)),
#                   labels = list(waiver(), scales::percent),
#                   guide = "colourfan") + theme_void()

map_took_pres <- ggplot() + 
  geom_polygon(data=merged_pres, 
          aes(x=long, y=lat, group=group, fill = Value, frame =  t), 
          color="white", size = 0.2) +
  scale_fill_gradient(
    low = "lightblue", high = "darkred",
    name = c("Percentage")) + 
  geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
  theme_classic()+
  theme(axis.line=element_blank(),
      axis.text.x=element_blank(),
      axis.text.y=element_blank(),
      axis.ticks=element_blank(),
      axis.title.x=element_blank(),
      axis.title.y=element_blank())+
  labs(title="Took Prescription Medication for Mental Health, Last 4 Weeks", fill = "%") 

fig <- ggplotly(map_took_pres) 
fig <- fig %>% 
  animation_opts(
    50, easing = "elastic", redraw = FALSE
  ) %>%
  animation_slider(
    currentvalue = list(prefix = "Time Period ", font = list(color="red"))
  ) #%>%
  # layout(annotations = list(x = -120, y = 25, text = paste("Time Period: ",
  #   merged_pres$`Time Period Label`), showarrow = F))
  

fig$x$frames <- lapply(
  fig$x$frames, function(f) { 
    f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
    f 
  })

fig

Received Counseling or Therapy, Last 4 Weeks

data_states_13_thrp <- data %>% 
  filter(Indicator == "Received Counseling or Therapy, Last 4 Weeks",
         Group == "By State") %>% 
  mutate(State1 = tolower(State)) %>%
  select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`) 

# merge with state
merged_thrp <- inner_join(MainStates, data_states_13_thrp, by = "State")

map_thrp <- ggplot() + 
  theme_classic()+
  geom_polygon(data=merged_thrp, 
          aes(x=long, y=lat, group=group, fill = Value, frame =  t), 
          color="white", size = 0.2) +
  scale_fill_gradient(
    low = "lightblue", high = "darkred",
    name = c("Percentage")) + 
  geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
  theme(axis.line=element_blank(),
        axis.text.x=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks=element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank())+
  labs(title="Received Counseling or Therapy, Last 4 Weeks", fill = "%")

fig2 <- ggplotly(map_thrp) 
fig2 <- fig2 %>% 
  animation_opts(
    50, easing = "elastic", redraw = FALSE
  )%>%
  animation_slider(
    currentvalue = list(prefix = "Time Period ", font = list(color="red"))
  )

fig2$x$frames <- lapply(
  fig2$x$frames, function(f) { 
    f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
    f 
  })

fig2

Took Prescription Medication for Mental Health And/Or Received Counseling or Therapy, Last 4 Weeks

data_states_13_both <- data %>% 
  filter(Indicator == "Took Prescription Medication for Mental Health And/Or Received Counseling or Therapy, Last 4 Weeks",
         Group == "By State") %>% 
  mutate(State1 = tolower(State)) %>%
  select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`) 

# merge with state
merged_both <- inner_join(MainStates, data_states_13_both, by = "State")

map_both <- ggplot() + 
  theme_classic() +
  geom_polygon(data=merged_both, 
          aes(x=long, y=lat, group=group, fill = Value, frame =  t), 
          color="white", size = 0.2) +
  scale_fill_gradient(
    low = "lightblue", high = "darkred",
    name = c("Percentage")) + 
  geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
  labs(title="Took Prescription Medication for Mental Health And/Or <br> Received Counseling or Therapy, Last 4 Weeks", fill = "%")+
  theme(axis.line=element_blank(),
      axis.text.x=element_blank(),
      axis.text.y=element_blank(),
      axis.ticks=element_blank(),
      axis.title.x=element_blank(),
      axis.title.y=element_blank())

fig3 <- ggplotly(map_both) 
fig3 <- fig3 %>% 
  animation_opts(
    50, easing = "elastic", redraw = FALSE
  )%>%
  animation_slider(
    currentvalue = list(prefix = "Time Period ", font = list(color="red"))
  )

fig3$x$frames <- lapply(
  fig3$x$frames, function(f) { 
    f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
    f 
  })

fig3

Needed Counseling or Therapy But Did Not Get It, Last 4 Weeks

data_states_13_need <- data %>% 
  filter(Indicator == "Needed Counseling or Therapy But Did Not Get It, Last 4 Weeks",
         Group == "By State" ) %>% 
  mutate(State1 = tolower(State)) %>%
  select(Value, State = State1, Indicator, t = `Time Period`, `Time Period Label`) 

# merge with state
merged_need <- inner_join(MainStates, data_states_13_need, by = "State")

map_need <- ggplot() + 
  theme_classic() +
  geom_polygon(data=merged_need, 
          aes(x=long, y=lat, group=group, fill = Value, frame =  t), 
          color="white", size = 0.2) +
  scale_fill_gradient(
    low = "lightblue", high = "darkred",
    name = c("Percentage")) + 
  geom_text(aes(label = State,x = long, y = lat), data = region.lab.data, size=1, alpha = 0.001) +
  labs(title="Needed Counseling or Therapy But Did Not Get It, Last 4 Weeks", fill = "%")+
  theme(axis.line=element_blank(),
        axis.text.x=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks=element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank())

fig4 <- ggplotly(map_need) 
fig4 <- fig4 %>% 
  animation_opts(
    50, easing = "elastic", redraw = FALSE
  )%>%
  animation_slider(
    currentvalue = list(prefix = "Time Period ", font = list(color="red"))
  )

fig4$x$frames <- lapply(
  fig4$x$frames, function(f) { 
    f$data <- lapply(f$data, function(d) d[!names(d) %in% c("x", "y")])
    f 
  })

fig4

Period mismatch

data%>% 
  distinct(`Time Period`, 
           `Time Period Label`)

## # A tibble: 16 x 2
##    `Time Period` `Time Period Label`
##            <dbl> <chr>              
##  1            13 Aug 19 - Aug 31    
##  2            14 Sep 2 - Sep 14     
##  3            15 Sep 16 - Sep 28    
##  4            16 Sep 30 - Oct 12    
##  5            17 Oct 14 - Oct 26    
##  6            18 Oct 28 - Nov 9     
##  7            19 Nov 11 - Nov 23    
##  8            20 Nov 25 - Dec 7     
##  9            21 Dec 9 - Dec 21     
## 10             1 Dec 22 - Jan 5     
## 11            22 Jan 6 - Jan 18     
## 12            23 Jan 20 - Feb 1     
## 13            24 Feb 3 - Feb 15     
## 14            25 Feb 17 - Mar 1     
## 15            26 Mar 3 - Mar 15     
## 16            27 Mar 17 - Mar 29

Mar 17 - Mar 29 –> 27 Dec 22 - Jan 5 –> 1 –> between 21 and 22

period numbers mismatch

add national averages

add state label

Hover for drop down

By indicator, Drop down info: state, gender, race

## Resource https://plotly.com/r/choropleth-maps/

data_state_pres <- data %>% 
  filter(Indicator == "Took Prescription Medication for Mental Health, Last 4 Weeks")%>%
  pivot_wider(names_from = c("Subgroup"), values_from = "Value") %>%
  distinct(.keep_all = T)
# data$hover <- with(data, paste(State, '<br>', "Female", Female, "Male", Male, "<br>",
#                                "Hispanic or Latino", `Hispanic or Latino`, "<br>",
#                                "White", `Non-Hispanic white, single race`,
#                                "Asian", `Non-Hispanic Asian, single race`,"<br>",
#                                "Black", `Non-Hispanic black, single race`, "Other/Multiple Races", 
#                                `Non-Hispanic, other races and multiple races`))
# 
# fig <- plot_geo(df, locationmode = 'USA-states')
# fig <- fig %>% add_trace(
#     z = ~total.exports, text = ~hover, locations = ~code,
#     color = ~total.exports, colors = 'Purples'
#   )
# fig <- fig %>% colorbar(title = "Millions USD")
# fig <- fig %>% layout(
#     title = '2011 US Agriculture Exports by State<br>(Hover for breakdown)'
#   )
# 
# fig